perm filename DRAW.F4[MSS,LCS] blob sn#147665 filedate 1975-02-25 generic text, type T, neo UTF8
00100	C TYPE 'DO DOD.DO'.
00110	C  'G' OR <CR> = GET.  'A'=ADD TO COMBINED FILE.
00200	C PC=PLOT  PX=XGP(→PLOT.BIN)  PXS,PCS=PLOT SMOOTHED CONTURE
00300	C  PXZ,PCZ=PLOT SMOOTHED CONTURE AND FILL IT.
00400	C IN DRAW SECTION: J=JUMP(INVIS. VECT.)
00500	C  F=JUMP AND BEGIN FILL SECTION.  FX=EXIT AND FILL ALL.
00600	C SINGLE ITEM IS RESTRICTED TO 400 WDS. 10 ITEMS PER FILE.
00610	C  'Q' MAKES CURRENT DPY IN BACKGROUND ON POG2
00700		COMMON /RC/MCLEF(400),IST(4000)
00800		COMMON /FL/IC,N,NQ,RZ,IXRX,XGP,RXGP
00900		COMMON/ZN/SCLEF(400,2),DDD /ED/KED,NEXT,NN,NX,NY,J
01100		COMMON XX(100),G(100),NJ,QF(512),RF(512),S(100),K
01300		DIMENSION JCLEF(10),KCLEF(10),NMLST(10),JST(1)
01400		COMMON/NFF/NF(1539) /LL/LL /RZ/RSZ,IPLT,RJB,CENTR
01460		EQUIVALENCE (MM,SCLEF(1,1)),(JCLEF,IST(1490)),(NM,IXRX)
01510		1 ,(GRID,IST(4000)),(KCLEF,IST(1500))
01600		1 ,(NMLST,IST(1510)),(JST,IST(500))
01700		DATA RJB/-20./,CENTR/-26./
01710		RSZ=0
01800	1	MCLEF(1)=0
02000		MM=0
02100		IPLT=0
02200		IPLTX=-1
02300		K=1
02500	91	TYPE 100
02600	55	FORMAT(I,2F)
02700	50	FORMAT(3A1)
02900		XSZ=RSZ
03000		ACCEPT 55,J,RSZ,GRID
03200		IF(RSZ.EQ.0)RSZ=XSZ
03300		MORE=-1
03400		REREAD 50,N,JC,JS
03410		IF(N.EQ.' ')GO TO 91
03500	C PXS,PCS=SMOOTH ONLY;  PXZ,PCZ=SMOOTH AND FILL
03600	C  TO SAVE SIZE FACTOR WHEN REDRAWING.
03610		IF(N.EQ.'Z')GO TO 1
03700		IF(RSZ.EQ.0)RSZ=9.0
03710		IF(GRID.NE.0.AND.N.NE.'P')CALL GRIDS
03800		IF(N.EQ.'M'.OR.N.EQ.'R')GO TO 192
03850		IF(N.EQ.'V')CALL CNVT
03875	C  V=CONVERT FROM OLD FORMAT TO NEW.
03900	C  FOR ROTATION OR MOVING AND DISTORTING ENTIRE PICTURE
03910		IF(N.EQ.'F')GO TO 79
03930	C  FILLS IT.
03950		IF(JS.EQ.'L')N='Z'
03975	C  DEL=DELETE FROM COMB. FILE.   (JS='L')
04000		IF(N.EQ.'C'.OR.N.EQ.'A'.OR.N.EQ.'Z')GO TO 999
04100	CC	IF(N.EQ.'X')CALL EXIT
04200	C TYPE X TO FINISH PLOT, OTHERWISE NEW UNIT MAY BE READ IN.
04300		IF(N.EQ.'Q')GO TO 56
04350	C  'Q' MAKES CURRENT DPY IN BACKGROUND ON POG2
04400		IF(N.NE.'D'.AND.N.NE.'E')GO TO 191
04500	
04600		KED=N
04700		MM=MCLEF(1)
04800		IF(MM.NE.0)GO TO 92
04900	C  ADD TO DRAWING?
05000		GO TO 3
05010	
05020	56	CALL POG2
05030		CALL RDRAW(2,MCLEF(1),MCLEF)
05035		CALL DPYOUT(2)
05040		CALL POG1
05050		GO TO 91
05100	999	CALL CMBN
05200		GO TO 111
05250	192	IF(N.EQ.'R')MCLEF(1)=-MCLEF(1)
05300		CALL SHIFT(MCLEF(2),MCLEF(1))
05400		J=1
05500		JC=0
05600		GO TO 333
05700	191	TYPE 41
05900		IF(JC.EQ.'M'.OR.N.EQ.'S')GO TO 194
06000		MCLEF(1)=0
06100		MM=0
06200		IPLTX=-1
06300		K=1
06400	194	IF(JC.EQ.'M')MORE=0
06500		JQ=JC
06600		JC=0
06700		JM=1
06900		IF(MCLEF(1).EQ.0)GO TO 193
07140		JM=MCLEF(1)+1
07200	193	ACCEPT 10,NM,PASS
07210		IF(NM.EQ.' ')NM=LASTNM
07300		IF(NM.EQ.' '.OR.NM.EQ.'99')GO TO 91
07305	C  '99'  WILL BACKUP
07310		IF(N.NE.'S')LASTNM=NM
07500		IF(N.EQ.'S')GO TO 40
07600		IF(LOOKF(NM).EQ.0)GO TO 191
07700	C  'FAIL' ROUTINE TO CHECK ON LOOKUP
07950		CALL RDSAV(KCLEF,NMLST,M,NM,JST,-1)
07970	C  -1=READ
08000	C  CAN'T USE 'GM' WITH 'COMBINED' FILE.
08010		J=1
08020		IF(KCLEF(2).EQ.0)GO TO 290
08100		TYPE 1100
08200		ACCEPT 55,J
08300		J=J+1
08350	C  ITEMS ARE NUMBERED  0 THROUGH 9 (10 ITEMS).
08375		IF(J.GT.10)GO TO 191
08420	290	IC=KCLEF(J)+JST(KCLEF(J))-1
08500		TYPE 110,IC
09910	60	JZ=1
09917		IF(MORE.EQ.0)JZ=JM
09920		L=KCLEF(J)-1
09930		DO 61 K=JZ,JST(L+1)+JZ-1
09935		L=L+1
09937		M=K
09940	61	MCLEF(K)=JST(L)
09960		MCLEF(1)=M
10000	1100	FORMAT(' ITEM NUM?'/)
10100	700	FORMAT(' RESET X-Y POS. ',$)
10200	555	FORMAT(2F)
10300	7	IF(MORE)GO TO 70
10400		DO 771 K=2,JM
10500	771	IF(MCLEF(K).GE.200000000)GO TO 772
10600		GO TO 70
11710	772	M=MCLEF(1)
11720		DO 773 L=K,JM
11730		M=M+1
11740	773	MCLEF(M)=MCLEF(L)
11750		K=MJ+K
11760		DO 774 L=JM,M
11770	774	MCLEF(L-K)=MCLEF(L)
11800		GO TO 3
12600	
12700	70	IF(N.NE.'P')GO TO 3
12800		IXRX=-1
12900		IF(JQ.NE.'X')IXRX=0
13000	C 0=SEND IT TO CALCOMP
13100		TYPE 700
13200		ACCEPT 555,X,Y
13300		IF(X.NE.0)RJB=X/RSZ
13400		IF(Y.NE.0)CENTR=Y/RSZ
13500	C  TYPE .001, .001 TO SET POS. TO 0, -20, -26 IS ORIGINAL.
13600		IF(IPLTX)CALL PLOTS(0)
13700	C  DO I NEED THIS?
13710		IF(GRID.GT.0)CALL GRIDS
13800		IPLTX=0
13900		IPLT=-1
14000	3	IF(N.NE.'D')MM=0
14100	C  RESET IF NOT GOING TO DRAWIT
14400	333	IF(N.EQ.'P')GO TO 337
14500		CALL DPYSET(1,IST,4000)
14600		CALL DPYBRT(4)
14700		NIST=IST(2)
14800		IF(N.AND.N.NE.'G'.AND.N.NE.'M'.AND.N.NE.'R')GO TO 92
15000	337	IF(JS.EQ.'Z')GO TO 306
15100		IF(JS.NE.'S')GO TO 338
15200		CALL SMOOTH(JS)
15300		GO TO 436
15400	338	IC=-1
15500		MM=1
15600		DO 335 K=2,MCLEF(1)
15700		IF(MCLEF(K).LT.200000000)GO TO 335
16200		IC=K
16300		GO TO 334
16400	C FOR 1ST LOC. OF MCLEF IN FILLER
16500	335	CONTINUE
16600	334	CALL RDRAW(2,MCLEF(1),MCLEF)
16700		CALL DPYOUT(1)
16800		NIST=IST(2)
16950		GO TO 436
17000	C NO FILLER
17010	79	IF(IC)GO TO 91
17020	C  IC=-1 IF NO FILLER WAS REQUESTED WHILE DRAWING.
17100		TYPE 336
17200		ACCEPT 10,J
17300		JZ=N
17500		KK=0
17600		IF(J.NE.'Y')GO TO 206
17700	306	CALL SMOOTH(0)
17750	C  SMOOTHS AND FILLS
17800		GO TO 436
17900	206	RR=RSZ
18100		DO 205 J=IC,MCLEF(1)
18200		CALL UNPACK(J,M,N,MCLEF)
18300		KK=KK+1
18350		KX=KK*3
18400		NF(KX)=2
18500		IF(LL.GE.100000000)NF(KX)=3
18600		QF(KK)=(M+RJB)*RR
18700	205	RF(KK)=(N+CENTR)*RR
18800		NF(3)=KX
18900		CALL FILLQ(QF,RF,NF)
19000	436	IF(JZ.EQ.'P')CALL PLOT(0,0,3)
19100		GO TO 91
19105	
19110	66	TYPE 666,NM
19120		GO TO 91
19130	666	FORMAT(' MORE THAN ONE ITEM IN FILE ',A5/)
19200	336	FORMAT(' SMOOTH? ',$)
19300	10	FORMAT(A5,F)
19400	5	FORMAT(12I)
19500	100	FORMAT(' G=GET, GM=GET MORE, =S=SAVE, D=DRAW, X=EXIT, M=MOVE,'/'
19600		1 P=PLOT, PX=XGP, C=COMBINE, A=ADD TO COMB. FILE
19650		1, DEL=DEL. FROM COMB.'/
19700		1' F=FILL,  E=EDIT,   N1=SIZE, N2=1=GRID '/)
19800	C  N1=20 TO CHANGE SHAPE
19900	
20000	92	IST(2)=NIST
20100		CALL DRAWIT
20200	  	N=0
20300		GO TO 3
20400	
20500	403	FORMAT(' WRITE OVER ',A5,'.DMD?  ',$)
20600	41	FORMAT(' TYPE FILE NAME'/)
20700	C  SAVES ONLY ONE PICTURE - USE 999(COMBINE) FOR UP TO 9
20800	40	IF(LOOKF(NM).EQ.0)GO TO 402
20900		TYPE 403,NM
21000		ACCEPT 50,K
21100		IF(K.EQ.'N')GO TO 191
21210	402	NMLST(1)=NM
21220		JCLEF(1)=1
21230		DO 1111 K=2,10
21240		JCLEF(K)=0
21250	1111	NMLST(K)=' '
21260		CALL RDSAV(JCLEF,NMLST,MCLEF(1),NM,MCLEF,0)
21280		NQ=MCLEF(1)
21600	111	TYPE 110,NQ
21620		GO TO 91
21800	110	FORMAT(' TOTAL WDS=',I3)
21900		END